home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / cmpnew / cmpinline.lsp < prev    next >
Lisp/Scheme  |  1987-06-03  |  19KB  |  442 lines
  1. ;;; CMPINLINE  Open coding optimizer.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7. (in-package 'compiler)
  8.  
  9. ;;; Pass 1 generates the internal form
  10. ;;;    ( id  info-object . rest )
  11. ;;; for each form encountered.
  12.  
  13. (defstruct info
  14.   (changed-vars nil)    ;;; List of var-objects changed by the form.
  15.   (referred-vars nil)    ;;; List of var-objects referred in the form.
  16.   (type t)        ;;; Type of the form.
  17.   (sp-change nil)    ;;; Whether execution of the form may change
  18.             ;;; the value of a special variable *VS*.
  19.   )
  20.  
  21. (defvar *info* (make-info))
  22.  
  23. (defun add-info (to-info from-info)
  24.   (setf (info-changed-vars to-info)
  25.         (append (info-changed-vars from-info)
  26.                 (info-changed-vars to-info)))
  27.   (setf (info-referred-vars to-info)
  28.         (append (info-referred-vars from-info)
  29.                 (info-referred-vars to-info)))
  30.   (when (info-sp-change from-info)
  31.         (setf (info-sp-change to-info) t))
  32.   )
  33.  
  34. (defun args-info-changed-vars (var forms)
  35.   (case (var-kind var)
  36.         ((LEXICAL FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT)
  37.          (dolist** (form forms)
  38.            (when (member var (info-changed-vars (cadr form)))
  39.                  (return-from args-info-changed-vars t))))
  40.         (REPLACED nil)
  41.         (t (dolist** (form forms nil)
  42.              (when (or (member var (info-changed-vars (cadr form)))
  43.                        (info-sp-change (cadr form)))
  44.                    (return-from args-info-changed-vars t)))))
  45.   )
  46.  
  47. (defun args-info-referred-vars (var forms)
  48.   (case (var-kind var)
  49.         ((LEXICAL REPLACED FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT)
  50.          (dolist** (form forms nil)
  51.            (when (member var (info-referred-vars (cadr form)))
  52.                  (return-from args-info-referred-vars t))))
  53.         (t (dolist** (form forms nil)
  54.              (when (or (member var (info-referred-vars (cadr form)))
  55.                        (info-sp-change (cadr form)))
  56.                    (return-from args-info-referred-vars t))))
  57.         ))
  58.  
  59. ;;; Valid property names for open coded functions are:
  60. ;;;  INLINE
  61. ;;;  INLINE-SAFE    safe-compile only
  62. ;;;  INLINE-UNSAFE    non-safe-compile only
  63. ;;;
  64. ;;; Each property is a list of 'inline-info's, where each inline-info is:
  65. ;;; ( types { type | boolean } side-effect new-object { string | function } ).
  66. ;;;
  67. ;;; For each open-codable function, open coding will occur only if there exits
  68. ;;; an appropriate property with the argument types equal to 'types' and with
  69. ;;; the return-type equal to 'type'.  The third element
  70. ;;; is T if and only if side effects may occur by the call of the function.
  71. ;;; Even if *VALUE-TO-GO* is TRASH, open code for such a function with side
  72. ;;; effects must be included in the compiled code.
  73. ;;; The forth element is T if and only if the result value is a new Lisp
  74. ;;; object, i.e., it must be explicitly protected against GBC.
  75.  
  76. (defvar *inline-functions* nil)
  77. (defvar *inline-blocks* 0)
  78. ;;; *inline-functions* holds:
  79. ;;;    (...( function-name . inline-info )...)
  80. ;;;
  81. ;;; *inline-blocks* holds the number of temporary cvars used to save
  82. ;;; intermediate results during evaluation of inlined function calls.
  83. ;;; This variable is used to close up blocks introduced to declare static
  84. ;;; c variables.
  85.  
  86. (defun inline-args (forms types &aux (locs nil) ii)
  87.   (do ((forms forms (cdr forms))
  88.        (types types (cdr types)))
  89.       ((endp forms) (reverse locs))
  90.       (declare (object forms types))
  91.       (let ((form (car forms))
  92.             (type (car types)))
  93.         (declare (object form type))
  94.         (case (car form)
  95.               (LOCATION (push (coerce-loc (caddr form) type) locs))
  96.               (VAR
  97.                (cond ((args-info-changed-vars (caaddr form) (cdr forms))
  98.                       (cond ((and (member (var-kind (caaddr form))
  99.                                           '(FIXNUM CHARACTER LONG-FLOAT
  100.                                                    SHORT-FLOAT))
  101.                                   (eq type (var-kind (caaddr form))))
  102.                              (let ((cvar (next-cvar)))
  103.                                (wt-nl "{" (rep-type type) "V" cvar "= V"
  104.                                       (var-loc (caaddr form)) ";")
  105.                                (push (list 'cvar cvar) locs)
  106.                                (incf *inline-blocks*)))
  107.                             ((eq (var-kind (caaddr form)) 'OBJECT)
  108.                              (let ((cvar (next-cvar)))
  109.                                (wt-nl "{object V" cvar "= V"
  110.                                       (var-loc (caaddr form)) ";")
  111.                                (push (coerce-loc (list 'cvar cvar) type) locs)
  112.                                (incf *inline-blocks*)))
  113.                             (t 
  114.                              (let ((temp (list 'VS (vs-push))))
  115.                                (wt-nl temp "= ")
  116.                                (wt-var (caaddr form) (cadr (caddr form)))
  117.                                (wt ";")
  118.                                (push (coerce-loc temp type) locs)))))
  119.                      ((and (member (var-kind (caaddr form))
  120.                                    '(FIXNUM LONG-FLOAT SHORT-FLOAT))
  121.                            (not (eq type (var-kind (caaddr form)))))
  122.                       (let ((temp (list 'VS (vs-push))))
  123.                         (wt-nl temp "= ")
  124.                         (wt-var (caaddr form) (cadr (caddr form)))
  125.                         (wt ";")
  126.                         (push (coerce-loc temp type) locs)))
  127.                      (t (push (coerce-loc (cons 'VAR (caddr form)) type)
  128.                               locs))))
  129.               (CALL-GLOBAL
  130.                (if (let ((fname (caddr form)))
  131.                         (declare (object fname))
  132.                         (and (inline-possible fname)
  133.                              (setq ii (get-inline-info
  134.                                        fname (cadddr form)
  135.                                        (info-type (cadr form))))))
  136.                    (let ((loc (get-inline-loc ii (cadddr form))))
  137.                         (cond
  138.                          ((or (cadddr ii)    ; returns new object
  139.                               (and (member (cadr ii)
  140.                                            '(FIXNUM LONG-FLOAT SHORT-FLOAT))
  141.                                    (not (eq type (cadr ii)))))
  142.                           (let ((temp (list 'VS (vs-push))))
  143.                                (wt-nl temp "= " loc ";")
  144.                                (push (coerce-loc temp type) locs)))
  145.                          ((or (need-to-protect (cdr forms) (cdr types))
  146.                               (and (caddr ii) ; side-effectp
  147.                                    (not (null (cdr forms)))))
  148.                           (let ((cvar (next-cvar)))
  149.                             (wt-nl "{" (rep-type type) "V" cvar "= ")
  150.                             (case type
  151.                               (fixnum (wt-fixnum-loc loc))
  152.                               (character (wt-character-loc loc))
  153.                               (long-float (wt-long-float-loc loc))
  154.                               (short-float (wt-short-float-loc loc))
  155.                               (otherwise (wt-loc loc)))
  156.                             (wt ";")
  157.                             (push (list 'cvar cvar) locs)
  158.                             (incf *inline-blocks*))
  159.                             )
  160.                          (t (push (coerce-loc loc type) locs))))
  161.                    (let ((temp (list 'VS (vs-push))))
  162.                         (let ((*value-to-go* temp)) (c2expr* form))
  163.                         (push (coerce-loc temp type) locs))))
  164.               (structure-ref
  165.                (push (coerce-loc (list 'structure-ref
  166.                                        (car (inline-args (list (caddr form))
  167.                                                          '(t)))
  168.                                        (cadddr form)
  169.                                        (car (cddddr form)))
  170.                                  type)
  171.                      locs))
  172.               (SETQ
  173.                (let ((vref (caddr form))
  174.                      (form1 (cadddr form)))
  175.                  (let ((*value-to-go* (cons 'var vref))) (c2expr* form1))
  176.                  (cond ((eq (car form1) 'LOCATION)
  177.                         (push (coerce-loc (caddr form1) type) locs))
  178.                        (t (setq forms (list* form
  179.                                              (list 'VAR (cadr form) vref)
  180.                                              (cdr forms)))
  181.                           (setq types (list* type type types))))))
  182.               (t (let ((temp (list 'VS (vs-push))))
  183.                       (let ((*value-to-go* temp)) (c2expr* form))
  184.                       (push (coerce-loc temp type) locs))))))
  185.   )
  186.  
  187. (defun coerce-loc (loc type)
  188.   (case type
  189.         (fixnum (list 'FIXNUM-LOC loc))
  190.         (character (list 'CHARACTER-LOC loc))
  191.         (long-float (list 'LONG-FLOAT-LOC loc))
  192.         (short-float (list 'SHORT-FLOAT-LOC loc))
  193.         (t loc)))
  194.  
  195. (defun get-inline-loc (ii args &aux (locs (inline-args args (car ii)))
  196.                                     (fun (car (cddddr ii))))
  197.   ;;; Those functions that use GET-INLINE-LOC must rebind the variable *VS*.
  198.   (when (and (stringp fun) (char= (char (the string fun) 0) #\@))
  199.     (let ((i 1) (saves nil))
  200.          (declare (fixnum i))
  201.       (do ((char (char (the string fun) i)
  202.                  (char (the string fun) i)))
  203.           ((char= char #\;) (incf i))
  204.           (declare (character char))
  205.           (push (the fixnum (- (char-code char) #.(char-code #\0))) saves)
  206.           (incf i))
  207.       (do ((l locs (cdr l))
  208.            (n 0 (1+ n))
  209.            (locs1 nil))
  210.           ((endp l) (setq locs (reverse locs1)))
  211.           (declare (fixnum n) (object l))
  212.           (if (member n saves)
  213.               (let* ((loc1 (car l)) (loc loc1) (coersion nil))
  214.                     (declare (object loc loc1))
  215.                 (when (and (consp loc1)
  216.                            (member (car loc1)
  217.                                    '(FIXNUM-LOC CHARACTER-LOC
  218.                                      LONG-FLOAT-LOC SHORT-FLOAT-LOC)))
  219.                       (setq coersion (car loc1))
  220.                       (setq loc (cadr loc1))  ; remove coersion
  221.                       )
  222.                 (cond
  223.                  ((and (consp loc)
  224.                        (and (member (car loc) 
  225.                                     '(INLINE INLINE-COND INLINE-FIXNUM
  226.                                       INLINE-CHARACTER INLINE-LONG-FLOAT
  227.                                       INLINE-SHORT-FLOAT))
  228.                             (cadr loc)  ;; side-effect-p
  229.                             ))
  230.                   (wt-nl "{")
  231.                   (incf *inline-blocks*)
  232.                   (let ((cvar (next-cvar)))
  233.                     (push (list 'CVAR cvar) locs1)
  234.                     (case coersion
  235.                      ((nil) (wt "object V" cvar "= ") (wt-loc loc1))
  236.                      (FIXNUM-LOC (wt "int V" cvar "= ") (wt-fixnum-loc loc))
  237.                      (CHARACTER-LOC
  238.                       (wt "unsigned char V" cvar "= ") (wt-character-loc loc))
  239.                      (LONG-FLOAT-LOC
  240.                       (wt "double V" cvar "= ") (wt-long-float-loc loc))
  241.                      (SHORT-FLOAT-LOC
  242.                       (wt "float V" cvar "= ") (wt-short-float-loc loc))
  243.                      (t (baboon))))
  244.                   (wt ";")
  245.                   )
  246.                  (t (push loc1 locs1))))
  247.               (push (car l) locs1)))))
  248.   (list (case (cadr ii)
  249.               (boolean 'INLINE-COND)
  250.               (fixnum 'INLINE-FIXNUM)
  251.               (character 'INLINE-CHARACTER)
  252.               (long-float 'INLINE-LONG-FLOAT)
  253.               (short-float 'INLINE-SHORT-FLOAT)
  254.               (otherwise 'INLINE))
  255.         (caddr ii)
  256.         fun
  257.         locs)
  258.   )
  259.  
  260. (defun get-inline-info (fname args return-type &aux x ii)
  261.   (setq args (mapcar #'(lambda (form) (info-type (cadr form))) args))
  262.   (when (and (setq x (assoc fname *inline-functions*))
  263.              (setq ii (inline-type-matches (cdr x) args return-type)))
  264.         (return-from get-inline-info ii))
  265.   (when (if *safe-compile*
  266.             (setq x (get fname 'inline-safe))
  267.             (setq x (get fname 'inline-unsafe)))
  268.         (dolist** (y x nil)
  269.           (when (setq ii (inline-type-matches y args return-type))
  270.                 (return-from get-inline-info ii))))
  271.   (when (setq x (get fname 'inline-always))
  272.         (dolist** (y x)
  273.           (when (setq ii (inline-type-matches y args return-type))
  274.                 (return-from get-inline-info ii))))
  275.   nil
  276.   )
  277.  
  278. (defun inline-type-matches (inline-info arg-types return-type
  279.                                         &aux (rts nil))
  280.   (if (and (let ((types (car inline-info)))
  281.                 (declare (object types))
  282.                 (dolist** (arg-type arg-types (endp types))
  283.                   (when (endp types) (return nil))
  284.                   (cond ((eq (car types) 'fixnum-float)
  285.                          (cond ((type>= 'fixnum arg-type)
  286.                                 (push 'fixnum rts))
  287.                                ((type>= 'long-float arg-type)
  288.                                 (push 'long-float rts))
  289.                                ((type>= 'short-float arg-type)
  290.                                 (push 'short-float rts))
  291.                                (t (return nil))))
  292.                         ((type>= (car types) arg-type)
  293.                          (push (car types) rts))
  294.                         (t (return nil)))
  295.                   (pop types)))
  296.            (or (eq (cadr inline-info) 'boolean)
  297.                (type>= (cadr inline-info) return-type)))
  298.       (cons (reverse rts) (cdr inline-info))
  299.       nil)
  300.   )
  301.  
  302. (defun need-to-protect (forms types &aux ii)
  303.   (do ((forms forms (cdr forms))
  304.        (types types (cdr types)))
  305.       ((endp forms) nil)
  306.       (declare (object forms types))
  307.       (let ((form (car forms)))
  308.         (declare (object form))
  309.         (case (car form)
  310.               (LOCATION)
  311.               (VAR
  312.                (when (or (args-info-changed-vars (caaddr form) (cdr forms))
  313.                          (and (member (var-kind (caaddr form))
  314.                                       '(FIXNUM LONG-FLOAT SHORT-FLOAT))
  315.                               (not (eq (car types)
  316.                                        (var-kind (caaddr form))))))
  317.                      (return t)))
  318.               (CALL-GLOBAL
  319.                (let ((fname (caddr form)))
  320.                     (declare (object fname))
  321.                     (when
  322.                      (or (not (inline-possible fname))
  323.                          (null (setq ii (get-inline-info
  324.                                          fname (cadddr form)
  325.                                          (info-type (cadr form)))))
  326.                          (caddr ii)
  327.                          (cadddr ii)
  328.                          (and (member (cadr ii)
  329.                                       '(fixnum long-float short-float))
  330.                               (not (eq (car types) (cadr ii))))
  331.                          (need-to-protect (cadddr form) (car ii)))
  332.                      (return t))))
  333.               (structure-ref
  334.                (when (need-to-protect (list (caddr form)) '(t))
  335.                      (return t)))
  336.               (t (return t)))))
  337.   )
  338.  
  339. (defun close-inline-blocks ()
  340.        (dotimes** (i *inline-blocks*) (wt "}")))
  341.  
  342. (si:putprop 'inline 'wt-inline 'wt-loc)
  343. (si:putprop 'inline-cond 'wt-inline-cond 'wt-loc)
  344. (si:putprop 'inline-fixnum 'wt-inline-fixnum 'wt-loc)
  345. (si:putprop 'inline-character 'wt-inline-character 'wt-loc)
  346. (si:putprop 'inline-long-float 'wt-inline-long-float 'wt-loc)
  347. (si:putprop 'inline-short-float 'wt-inline-short-float 'wt-loc)
  348.  
  349. (defun wt-inline-loc (fun locs &aux (i 0))
  350.        (declare (fixnum i))
  351.   (cond ((stringp fun)
  352.          (when (char= (char (the string fun) 0) #\@)
  353.            (setq i 1)
  354.            (do ()
  355.                ((char= (char (the string fun) i) #\;) (incf i))
  356.                (incf i)))
  357.          (do ((size (length (the string fun))))
  358.              ((>= i size))
  359.              (declare (fixnum size))
  360.              (let ((char (char (the string fun) i)))
  361.                   (declare (character char))
  362.                   (cond ((char= char #\#)
  363.                          (wt-loc
  364.                           (nth (the fixnum
  365.                                     (- (char-code (char (the string fun)
  366.                                                         (the fixnum (1+ i))))
  367.                                        #.(char-code #\0)))
  368.                                locs))
  369.                          (incf i 2))
  370.                         (t
  371.                          (princ char *compiler-output1*)
  372.                          (incf i)))))
  373.          )
  374.         (t (apply fun locs))))
  375.  
  376. (defun wt-inline (side-effectp fun locs)
  377.   (declare (ignore side-effectp))
  378.   (wt-inline-loc fun locs))
  379.  
  380. (defun wt-inline-cond (side-effectp fun locs)
  381.   (declare (ignore side-effectp))
  382.   (wt "(") (wt-inline-loc fun locs) (wt "?Ct:Cnil)"))
  383.  
  384. (defun wt-inline-fixnum (side-effectp fun locs)
  385.   (declare (ignore side-effectp))
  386.   (when (zerop *space*) (wt "CMP"))
  387.   (wt "make_fixnum(") (wt-inline-loc fun locs) (wt ")"))
  388.  
  389. (defun wt-inline-character (side-effectp fun locs)
  390.   (declare (ignore side-effectp))
  391.   (wt "code_char(") (wt-inline-loc fun locs) (wt ")"))
  392.  
  393. (defun wt-inline-long-float (side-effectp fun locs)
  394.   (declare (ignore side-effectp))
  395.   (wt "make_longfloat(") (wt-inline-loc fun locs) (wt ")"))
  396.  
  397. (defun wt-inline-short-float (side-effectp fun locs)
  398.   (declare (ignore side-effectp))
  399.   (wt "make_shortfloat(") (wt-inline-loc fun locs) (wt ")"))
  400.  
  401. (defun args-cause-side-effect (forms &aux ii)
  402.   (dolist** (form forms nil)
  403.     (case (car form)
  404.           ((LOCATION VAR structure-ref))
  405.           (CALL-GLOBAL
  406.            (let ((fname (caddr form)))
  407.                 (declare (object fname))
  408.                 (unless (and (inline-possible fname)
  409.                              (setq ii (get-inline-info
  410.                                        fname (cadddr form)
  411.                                        (info-type (cadr form))))
  412.                              (not (caddr ii)) ; no side-effectp
  413.                              )
  414.                         (return t))))
  415.           (otherwise (return t)))))
  416.  
  417. ;;; Borrowed from CMPOPT.LSP
  418.  
  419. (defun list-inline (&rest x)
  420.        (wt "list(" (length x)) (dolist (loc x) (wt #\, loc)) (wt #\)))
  421.  
  422. (defun list*-inline (&rest x)
  423.   (case (length x)
  424.         (1 (wt (car x)))
  425.         (2 (wt "make_cons(" (car x) "," (cadr x) ")"))
  426.         (otherwise
  427.          (wt "listA(" (length x)) (dolist (loc x) (wt #\, loc)) (wt #\)))))
  428.  
  429. ;;; Borrowed from LFUN_LIST.LSP
  430.  
  431. (defun defsysfun (fname cname-string arg-types return-type
  432.                         never-change-special-var-p predicate)
  433.   ;;; The value NIL for each parameter except for fname means "not known".
  434.   (when cname-string (si:putprop fname cname-string 'Lfun))
  435.   (when arg-types
  436.         (si:putprop fname (mapcar 'type-filter arg-types) 'arg-types))
  437.   (when return-type (si:putprop fname (type-filter return-type) 'return-type))
  438.   (when never-change-special-var-p (si:putprop fname t 'no-sp-change))
  439.   (when predicate (si:putprop fname t 'predicate))
  440.   )
  441.  
  442.